home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / gnus-int.el.z / gnus-int.el
Encoding:
Text File  |  1998-05-21  |  15.8 KB  |  441 lines
  1. ;;; gnus-int.el --- backend interface functions for Gnus
  2. ;; Copyright (C) 1996,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;; Keywords: news
  6.  
  7. ;; This file is part of GNU Emacs.
  8.  
  9. ;; GNU Emacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; GNU Emacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.     See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22. ;; Boston, MA 02111-1307, USA.
  23.  
  24. ;;; Commentary:
  25.  
  26. ;;; Code:
  27.  
  28. (eval-when-compile (require 'cl))
  29.  
  30. (require 'gnus)
  31.  
  32. (defcustom gnus-open-server-hook nil
  33.   "Hook called just before opening connection to the news server."
  34.   :group 'gnus-start
  35.   :type 'hook)
  36.  
  37. ;;;
  38. ;;; Server Communication
  39. ;;;
  40.  
  41. (defun gnus-start-news-server (&optional confirm)
  42.   "Open a method for getting news.
  43. If CONFIRM is non-nil, the user will be asked for an NNTP server."
  44.   (let (how)
  45.     (if gnus-current-select-method
  46.     ;; Stream is already opened.
  47.     nil
  48.       ;; Open NNTP server.
  49.       (unless gnus-nntp-service
  50.     (setq gnus-nntp-server nil))
  51.       (when confirm
  52.     ;; Read server name with completion.
  53.     (setq gnus-nntp-server
  54.           (completing-read "NNTP server: "
  55.                    (mapcar (lambda (server) (list server))
  56.                        (cons (list gnus-nntp-server)
  57.                          gnus-secondary-servers))
  58.                    nil nil gnus-nntp-server)))
  59.  
  60.       (when (and gnus-nntp-server
  61.          (stringp gnus-nntp-server)
  62.          (not (string= gnus-nntp-server "")))
  63.     (setq gnus-select-method
  64.           (cond ((or (string= gnus-nntp-server "")
  65.              (string= gnus-nntp-server "::"))
  66.              (list 'nnspool (system-name)))
  67.             ((string-match "^:" gnus-nntp-server)
  68.              (list 'nnmh gnus-nntp-server
  69.                (list 'nnmh-directory
  70.                  (file-name-as-directory
  71.                   (expand-file-name
  72.                    (concat "~/" (substring
  73.                          gnus-nntp-server 1)))))
  74.                (list 'nnmh-get-new-mail nil)))
  75.             (t
  76.              (list 'nntp gnus-nntp-server)))))
  77.  
  78.       (setq how (car gnus-select-method))
  79.       (cond
  80.        ((eq how 'nnspool)
  81.     (require 'nnspool)
  82.     (gnus-message 5 "Looking up local news spool..."))
  83.        ((eq how 'nnmh)
  84.     (require 'nnmh)
  85.     (gnus-message 5 "Looking up mh spool..."))
  86.        (t
  87.     (require 'nntp)))
  88.       (setq gnus-current-select-method gnus-select-method)
  89.       (run-hooks 'gnus-open-server-hook)
  90.       (or
  91.        ;; gnus-open-server-hook might have opened it
  92.        (gnus-server-opened gnus-select-method)
  93.        (gnus-open-server gnus-select-method)
  94.        (gnus-y-or-n-p
  95.     (format
  96.      "%s (%s) open error: '%s'.  Continue? "
  97.      (car gnus-select-method) (cadr gnus-select-method)
  98.      (gnus-status-message gnus-select-method)))
  99.        (gnus-error 1 "Couldn't open server on %s"
  100.            (nth 1 gnus-select-method))))))
  101.  
  102. (defun gnus-check-group (group)
  103.   "Try to make sure that the server where GROUP exists is alive."
  104.   (let ((method (gnus-find-method-for-group group)))
  105.     (or (gnus-server-opened method)
  106.     (gnus-open-server method))))
  107.  
  108. (defun gnus-check-server (&optional method silent)
  109.   "Check whether the connection to METHOD is down.
  110. If METHOD is nil, use `gnus-select-method'.
  111. If it is down, start it up (again)."
  112.   (let ((method (or method gnus-select-method)))
  113.     ;; Transform virtual server names into select methods.
  114.     (when (stringp method)
  115.       (setq method (gnus-server-to-method method)))
  116.     (if (gnus-server-opened method)
  117.     ;; The stream is already opened.
  118.     t
  119.       ;; Open the server.
  120.       (unless silent
  121.     (gnus-message 5 "Opening %s server%s..." (car method)
  122.               (if (equal (nth 1 method) "") ""
  123.             (format " on %s" (nth 1 method)))))
  124.       (run-hooks 'gnus-open-server-hook)
  125.       (prog1
  126.       (gnus-open-server method)
  127.     (unless silent
  128.       (message ""))))))
  129.  
  130. (defun gnus-get-function (method function &optional noerror)
  131.   "Return a function symbol based on METHOD and FUNCTION."
  132.   ;; Translate server names into methods.
  133.   (unless method
  134.     (error "Attempted use of a nil select method"))
  135.   (when (stringp method)
  136.     (setq method (gnus-server-to-method method)))
  137.   (let ((func (intern (format "%s-%s" (car method) function))))
  138.     ;; If the functions isn't bound, we require the backend in
  139.     ;; question.
  140.     (unless (fboundp func)
  141.       (require (car method))
  142.       (when (and (not (fboundp func))
  143.          (not noerror))
  144.     ;; This backend doesn't implement this function.
  145.     (error "No such function: %s" func)))
  146.     func))
  147.  
  148.  
  149. ;;;
  150. ;;; Interface functions to the backends.
  151. ;;;
  152.  
  153. (defun gnus-open-server (method)
  154.   "Open a connection to METHOD."
  155.   (when (stringp method)
  156.     (setq method (gnus-server-to-method method)))
  157.   (let ((elem (assoc method gnus-opened-servers)))
  158.     ;; If this method was previously denied, we just return nil.
  159.     (if (eq (nth 1 elem) 'denied)
  160.     (progn
  161.       (gnus-message 1 "Denied server")
  162.       nil)
  163.       ;; Open the server.
  164.       (let ((result
  165.          (funcall (gnus-get-function method 'open-server)
  166.               (nth 1 method) (nthcdr 2 method))))
  167.     ;; If this hasn't been opened before, we add it to the list.
  168.     (unless elem
  169.       (setq elem (list method nil)
  170.         gnus-opened-servers (cons elem gnus-opened-servers)))
  171.     ;; Set the status of this server.
  172.     (setcar (cdr elem) (if result 'ok 'denied))
  173.     ;; Return the result from the "open" call.
  174.     result))))
  175.  
  176. (defun gnus-close-server (method)
  177.   "Close the connection to METHOD."
  178.   (when (stringp method)
  179.     (setq method (gnus-server-to-method method)))
  180.   (funcall (gnus-get-function method 'close-server) (nth 1 method)))
  181.  
  182. (defun gnus-request-list (method)
  183.   "Request the active file from METHOD."
  184.   (when (stringp method)
  185.     (setq method (gnus-server-to-method method)))
  186.   (funcall (gnus-get-function method 'request-list) (nth 1 method)))
  187.  
  188. (defun gnus-request-list-newsgroups (method)
  189.   "Request the newsgroups file from METHOD."
  190.   (when (stringp method)
  191.     (setq method (gnus-server-to-method method)))
  192.   (funcall (gnus-get-function method 'request-list-newsgroups) (nth 1 method)))
  193.  
  194. (defun gnus-request-newgroups (date method)
  195.   "Request all new groups since DATE from METHOD."
  196.   (when (stringp method)
  197.     (setq method (gnus-server-to-method method)))
  198.   (let ((func (gnus-get-function method 'request-newgroups t)))
  199.     (when func
  200.       (funcall func date (nth 1 method)))))
  201.  
  202. (defun gnus-server-opened (method)
  203.   "Check whether a connection to METHOD has been opened."
  204.   (when (stringp method)
  205.     (setq method (gnus-server-to-method method)))
  206.   (funcall (inline (gnus-get-function method 'server-opened)) (nth 1 method)))
  207.  
  208. (defun gnus-status-message (method)
  209.   "Return the status message from METHOD.
  210. If METHOD is a string, it is interpreted as a group name.   The method
  211. this group uses will be queried."
  212.   (let ((method (if (stringp method) (gnus-find-method-for-group method)
  213.           method)))
  214.     (funcall (gnus-get-function method 'status-message) (nth 1 method))))
  215.  
  216. (defun gnus-request-regenerate (method)
  217.   "Request a data generation from METHOD."
  218.   (when (stringp method)
  219.     (setq method (gnus-server-to-method method)))
  220.   (funcall (gnus-get-function method 'request-regenerate) (nth 1 method)))
  221.  
  222. (defun gnus-request-group (group &optional dont-check method)
  223.   "Request GROUP.  If DONT-CHECK, no information is required."
  224.   (let ((method (or method (inline (gnus-find-method-for-group group)))))
  225.     (when (stringp method)
  226.       (setq method (inline (gnus-server-to-method method))))
  227.     (funcall (inline (gnus-get-function method 'request-group))
  228.          (gnus-group-real-name group) (nth 1 method) dont-check)))
  229.  
  230. (defun gnus-list-active-group (group)
  231.   "Request active information on GROUP."
  232.   (let ((method (gnus-find-method-for-group group))
  233.     (func 'list-active-group))
  234.     (when (gnus-check-backend-function func group)
  235.       (funcall (gnus-get-function method func)
  236.            (gnus-group-real-name group) (nth 1 method)))))
  237.  
  238. (defun gnus-request-group-description (group)
  239.   "Request a description of GROUP."
  240.   (let ((method (gnus-find-method-for-group group))
  241.     (func 'request-group-description))
  242.     (when (gnus-check-backend-function func group)
  243.       (funcall (gnus-get-function method func)
  244.            (gnus-group-real-name group) (nth 1 method)))))
  245.  
  246. (defun gnus-close-group (group)
  247.   "Request the GROUP be closed."
  248.   (let ((method (inline (gnus-find-method-for-group group))))
  249.     (funcall (gnus-get-function method 'close-group)
  250.          (gnus-group-real-name group) (nth 1 method))))
  251.  
  252. (defun gnus-retrieve-headers (articles group &optional fetch-old)
  253.   "Request headers for ARTICLES in GROUP.
  254. If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
  255.   (let ((method (gnus-find-method-for-group group)))
  256.     (if (and gnus-use-cache (numberp (car articles)))
  257.     (gnus-cache-retrieve-headers articles group fetch-old)
  258.       (funcall (gnus-get-function method 'retrieve-headers)
  259.            articles (gnus-group-real-name group) (nth 1 method)
  260.            fetch-old))))
  261.  
  262. (defun gnus-retrieve-groups (groups method)
  263.   "Request active information on GROUPS from METHOD."
  264.   (when (stringp method)
  265.     (setq method (gnus-server-to-method method)))
  266.   (funcall (gnus-get-function method 'retrieve-groups) groups (nth 1 method)))
  267.  
  268. (defun gnus-request-type (group &optional article)
  269.   "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
  270.   (let ((method (gnus-find-method-for-group group)))
  271.     (if (not (gnus-check-backend-function 'request-type (car method)))
  272.     'unknown
  273.       (funcall (gnus-get-function method 'request-type)
  274.            (gnus-group-real-name group) article))))
  275.  
  276. (defun gnus-request-update-mark (group article mark)
  277.   "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
  278.   (let ((method (gnus-find-method-for-group group)))
  279.     (if (not (gnus-check-backend-function 'request-update-mark (car method)))
  280.     mark
  281.       (funcall (gnus-get-function method 'request-update-mark)
  282.            (gnus-group-real-name group) article mark))))
  283.  
  284. (defun gnus-request-article (article group &optional buffer)
  285.   "Request the ARTICLE in GROUP.
  286. ARTICLE can either be an article number or an article Message-ID.
  287. If BUFFER, insert the article in that group."
  288.   (let ((method (gnus-find-method-for-group group)))
  289.     (funcall (gnus-get-function method 'request-article)
  290.          article (gnus-group-real-name group) (nth 1 method) buffer)))
  291.  
  292. (defun gnus-request-head (article group)
  293.   "Request the head of ARTICLE in GROUP."
  294.   (let* ((method (gnus-find-method-for-group group))
  295.      (head (gnus-get-function method 'request-head t))
  296.      res clean-up)
  297.     (cond
  298.      ;; Check the cache.
  299.      ((and gnus-use-cache
  300.        (numberp article)
  301.        (gnus-cache-request-article article group))
  302.       (setq res (cons group article)
  303.         clean-up t))
  304.      ;; Use `head' function.
  305.      ((fboundp head)
  306.       (setq res (funcall head article (gnus-group-real-name group)
  307.              (nth 1 method))))
  308.      ;; Use `article' function.
  309.      (t
  310.       (setq res (gnus-request-article article group)
  311.         clean-up t)))
  312.     (when clean-up
  313.       (save-excursion
  314.     (set-buffer nntp-server-buffer)
  315.     (goto-char (point-min))
  316.     (when (search-forward "\n\n" nil t)
  317.       (delete-region (1- (point)) (point-max)))
  318.     (nnheader-fold-continuation-lines)))
  319.     res))
  320.  
  321. (defun gnus-request-body (article group)
  322.   "Request the body of ARTICLE in GROUP."
  323.   (let ((method (gnus-find-method-for-group group)))
  324.     (funcall (gnus-get-function method 'request-body)
  325.          article (gnus-group-real-name group) (nth 1 method))))
  326.  
  327. (defun gnus-request-post (method)
  328.   "Post the current buffer using METHOD."
  329.   (when (stringp method)
  330.     (setq method (gnus-server-to-method method)))
  331.   (funcall (gnus-get-function method 'request-post) (nth 1 method)))
  332.  
  333. (defun gnus-request-scan (group method)
  334.   "Request a SCAN being performed in GROUP from METHOD.
  335. If GROUP is nil, all groups on METHOD are scanned."
  336.   (let ((method (if group (gnus-find-method-for-group group) method))
  337.     (gnus-inhibit-demon t))
  338.     (funcall (gnus-get-function method 'request-scan)
  339.          (and group (gnus-group-real-name group)) (nth 1 method))))
  340.  
  341. (defsubst gnus-request-update-info (info method)
  342.   "Request that METHOD update INFO."
  343.   (when (stringp method)
  344.     (setq method (gnus-server-to-method method)))
  345.   (when (gnus-check-backend-function 'request-update-info (car method))
  346.     (funcall (gnus-get-function method 'request-update-info)
  347.          (gnus-group-real-name (gnus-info-group info))
  348.          info (nth 1 method))))
  349.  
  350. (defun gnus-request-expire-articles (articles group &optional force)
  351.   (let ((method (gnus-find-method-for-group group)))
  352.     (funcall (gnus-get-function method 'request-expire-articles)
  353.          articles (gnus-group-real-name group) (nth 1 method)
  354.          force)))
  355.  
  356. (defun gnus-request-move-article
  357.   (article group server accept-function &optional last)
  358.   (let ((method (gnus-find-method-for-group group)))
  359.     (funcall (gnus-get-function method 'request-move-article)
  360.          article (gnus-group-real-name group)
  361.          (nth 1 method) accept-function last)))
  362.  
  363. (defun gnus-request-accept-article (group method &optional last)
  364.   ;; Make sure there's a newline at the end of the article.
  365.   (when (stringp method)
  366.     (setq method (gnus-server-to-method method)))
  367.   (when (and (not method)
  368.          (stringp group))
  369.     (setq method (gnus-group-name-to-method group)))
  370.   (goto-char (point-max))
  371.   (unless (bolp)
  372.     (insert "\n"))
  373.   (let ((func (car (or method (gnus-find-method-for-group group)))))
  374.     (funcall (intern (format "%s-request-accept-article" func))
  375.          (if (stringp group) (gnus-group-real-name group) group)
  376.          (cadr method)
  377.          last)))
  378.  
  379. (defun gnus-request-replace-article (article group buffer)
  380.   (let ((func (car (gnus-group-name-to-method group))))
  381.     (funcall (intern (format "%s-request-replace-article" func))
  382.          article (gnus-group-real-name group) buffer)))
  383.  
  384. (defun gnus-request-associate-buffer (group)
  385.   (let ((method (gnus-find-method-for-group group)))
  386.     (funcall (gnus-get-function method 'request-associate-buffer)
  387.          (gnus-group-real-name group))))
  388.  
  389. (defun gnus-request-restore-buffer (article group)
  390.   "Request a new buffer restored to the state of ARTICLE."
  391.   (let ((method (gnus-find-method-for-group group)))
  392.     (funcall (gnus-get-function method 'request-restore-buffer)
  393.          article (gnus-group-real-name group) (nth 1 method))))
  394.  
  395. (defun gnus-request-create-group (group &optional method args)
  396.   (when (stringp method)
  397.     (setq method (gnus-server-to-method method)))
  398.   (let ((method (or method (gnus-find-method-for-group group))))
  399.     (funcall (gnus-get-function method 'request-create-group)
  400.          (gnus-group-real-name group) (nth 1 method) args)))
  401.  
  402. (defun gnus-request-delete-group (group &optional force)
  403.   (let ((method (gnus-find-method-for-group group)))
  404.     (funcall (gnus-get-function method 'request-delete-group)
  405.          (gnus-group-real-name group) force (nth 1 method))))
  406.  
  407. (defun gnus-request-rename-group (group new-name)
  408.   (let ((method (gnus-find-method-for-group group)))
  409.     (funcall (gnus-get-function method 'request-rename-group)
  410.          (gnus-group-real-name group)
  411.          (gnus-group-real-name new-name) (nth 1 method))))
  412.  
  413. (defun gnus-close-backends ()
  414.   ;; Send a close request to all backends that support such a request.
  415.   (let ((methods gnus-valid-select-methods)
  416.     (gnus-inhibit-demon t)
  417.     func method)
  418.     (while (setq method (pop methods))
  419.       (when (fboundp (setq func (intern
  420.                  (concat (car method) "-request-close"))))
  421.     (funcall func)))))
  422.  
  423. (defun gnus-asynchronous-p (method)
  424.   (let ((func (gnus-get-function method 'asynchronous-p t)))
  425.     (when (fboundp func)
  426.       (funcall func))))
  427.  
  428. (defun gnus-remove-denial (method)
  429.   (when (stringp method)
  430.     (setq method (gnus-server-to-method method)))
  431.   (let* ((elem (assoc method gnus-opened-servers))
  432.      (status (cadr elem)))
  433.     ;; If this hasn't been opened before, we add it to the list.
  434.     (when (eq status 'denied)
  435.       ;; Set the status of this server.
  436.       (setcar (cdr elem) 'closed))))
  437.  
  438. (provide 'gnus-int)
  439.  
  440. ;;; gnus-int.el ends here
  441.